home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sparc / type-vops.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  15.9 KB  |  472 lines
  1. ;;; -*- Package: SPARC -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: type-vops.lisp,v 1.9 91/11/09 02:38:22 wlott Exp $
  11. ;;; 
  12. ;;; This file contains the VM definition of type testing and checking VOPs
  13. ;;; for the SPARC.
  14. ;;;
  15. ;;; Written by William Lott.
  16. ;;;
  17. (in-package "SPARC")
  18.  
  19.  
  20. ;;;; Simple type checking and testing:
  21. ;;;
  22. ;;;    These types are represented by a single type code, so are easily
  23. ;;; open-coded as a mask and compare.
  24.  
  25. (define-vop (check-type)
  26.   (:args (value :target result :scs (any-reg descriptor-reg)))
  27.   (:results (result :scs (any-reg descriptor-reg)))
  28.   (:temporary (:type random :scs (non-descriptor-reg)) temp)
  29.   (:vop-var vop)
  30.   (:save-p :compute-only))
  31.  
  32. (define-vop (type-predicate)
  33.   (:args (value :scs (any-reg descriptor-reg)))
  34.   (:conditional)
  35.   (:info target not-p)
  36.   (:policy :fast-safe)
  37.   (:temporary (:type random :scs (non-descriptor-reg)) temp))
  38.  
  39. (eval-when (compile eval)
  40.  
  41. (defun cost-to-test-types (type-codes)
  42.   (+ (* 2 (length type-codes))
  43.      (if (> (apply #'max type-codes) vm:lowtag-limit) 7 2)))
  44.  
  45. (defmacro def-type-vops (pred-name check-name ptype error-code
  46.                    &rest type-codes)
  47.   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
  48.     `(progn
  49.        ,@(when pred-name
  50.        `((define-vop (,pred-name type-predicate)
  51.            (:translate ,pred-name)
  52.            (:generator ,cost
  53.          (test-type value temp target not-p ,@type-codes)))))
  54.        ,@(when check-name
  55.        `((define-vop (,check-name check-type)
  56.            (:generator ,cost
  57.          (let ((err-lab
  58.             (generate-error-code vop ,error-code value)))
  59.            (test-type value temp err-lab t ,@type-codes)
  60.            (move result value))))))
  61.        ,@(when ptype
  62.        `((primitive-type-vop ,check-name (:check) ,ptype))))))
  63.  
  64. ); eval-when (compile eval)
  65.  
  66. (def-type-vops fixnump nil nil nil vm:even-fixnum-type vm:odd-fixnum-type)
  67. (define-vop (check-fixnum check-type)
  68.   (:ignore temp)
  69.   (:generator 1
  70.     (inst taddcctv result value zero-tn)))
  71. (primitive-type-vop check-fixnum (:check) fixnum)
  72.  
  73.  
  74. (def-type-vops functionp check-function function
  75.   object-not-function-error vm:function-pointer-type)
  76.  
  77. (def-type-vops listp nil nil nil vm:list-pointer-type)
  78. (define-vop (check-list check-type)
  79.   (:generator 3
  80.     (inst and temp value lowtag-mask)
  81.     (inst cmp temp list-pointer-type)
  82.     (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap))
  83.     (move result value)))
  84. (primitive-type-vop check-list (:check) list)
  85.  
  86. (def-type-vops structurep nil nil nil vm:structure-pointer-type)
  87. (define-vop (check-structure check-type)
  88.   (:generator 3
  89.     (inst and temp value lowtag-mask)
  90.     (inst cmp temp structure-pointer-type)
  91.     (inst t :ne (logior (ash (tn-offset value) 8) object-not-structure-trap))
  92.     (move result value)))
  93. (primitive-type-vop check-structure (:check) structure)
  94.  
  95. (def-type-vops bignump check-bigunm bignum
  96.   object-not-bignum-error vm:bignum-type)
  97.  
  98. (def-type-vops ratiop check-ratio ratio
  99.   object-not-ratio-error vm:ratio-type)
  100.  
  101. (def-type-vops complexp check-complex complex
  102.   object-not-complex-error vm:complex-type)
  103.  
  104. (def-type-vops single-float-p check-single-float single-float
  105.   object-not-single-float-error vm:single-float-type)
  106.  
  107. (def-type-vops double-float-p check-double-float double-float
  108.   object-not-double-float-error vm:double-float-type)
  109.  
  110. (def-type-vops simple-string-p check-simple-string simple-string
  111.   object-not-simple-string-error vm:simple-string-type)
  112.  
  113. (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
  114.   object-not-simple-bit-vector-error vm:simple-bit-vector-type)
  115.  
  116. (def-type-vops simple-vector-p check-simple-vector simple-vector
  117.   object-not-simple-vector-error vm:simple-vector-type)
  118.  
  119. (def-type-vops simple-array-unsigned-byte-2-p
  120.   check-simple-array-unsigned-byte-2
  121.   simple-array-unsigned-byte-2
  122.   object-not-simple-array-unsigned-byte-2-error
  123.   vm:simple-array-unsigned-byte-2-type)
  124.  
  125. (def-type-vops simple-array-unsigned-byte-4-p
  126.   check-simple-array-unsigned-byte-4
  127.   simple-array-unsigned-byte-4
  128.   object-not-simple-array-unsigned-byte-4-error
  129.   vm:simple-array-unsigned-byte-4-type)
  130.  
  131. (def-type-vops simple-array-unsigned-byte-8-p
  132.   check-simple-array-unsigned-byte-8
  133.   simple-array-unsigned-byte-8
  134.   object-not-simple-array-unsigned-byte-8-error
  135.   vm:simple-array-unsigned-byte-8-type)
  136.  
  137. (def-type-vops simple-array-unsigned-byte-16-p
  138.   check-simple-array-unsigned-byte-16
  139.   simple-array-unsigned-byte-16
  140.   object-not-simple-array-unsigned-byte-16-error
  141.   vm:simple-array-unsigned-byte-16-type)
  142.  
  143. (def-type-vops simple-array-unsigned-byte-32-p
  144.   check-simple-array-unsigned-byte-32
  145.   simple-array-unsigned-byte-32
  146.   object-not-simple-array-unsigned-byte-32-error
  147.   vm:simple-array-unsigned-byte-32-type)
  148.  
  149. (def-type-vops simple-array-single-float-p check-simple-array-single-float
  150.   simple-array-single-float object-not-simple-array-single-float-error
  151.   vm:simple-array-single-float-type)
  152.  
  153. (def-type-vops simple-array-double-float-p check-simple-array-double-float
  154.   simple-array-double-float object-not-simple-array-double-float-error
  155.   vm:simple-array-double-float-type)
  156.  
  157. (def-type-vops base-char-p check-base-char base-char
  158.   object-not-base-char-error vm:base-char-type)
  159.  
  160. (def-type-vops system-area-pointer-p check-system-area-pointer
  161.   system-area-pointer object-not-sap-error vm:sap-type)
  162.  
  163. (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
  164.   object-not-weak-pointer-error vm:weak-pointer-type)
  165.  
  166. (def-type-vops scavenger-hook-p nil nil nil
  167.   0)
  168.  
  169. (def-type-vops code-component-p nil nil nil
  170.   vm:code-header-type)
  171.  
  172. (def-type-vops lra-p nil nil nil
  173.   vm:return-pc-header-type)
  174.  
  175. (def-type-vops funcallable-instance-p nil nil nil
  176.   vm:funcallable-instance-header-type)
  177.  
  178. (def-type-vops array-header-p nil nil nil
  179.   vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
  180.   vm:complex-vector-type vm:complex-array-type)
  181.  
  182. (def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
  183.   vm:function-pointer-type vm:symbol-header-type)
  184.  
  185. (def-type-vops stringp check-string nil object-not-string-error
  186.   vm:simple-string-type vm:complex-string-type)
  187.  
  188. (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
  189.   vm:simple-bit-vector-type vm:complex-bit-vector-type)
  190.  
  191. (def-type-vops vectorp check-vector nil object-not-vector-error
  192.   vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
  193.   vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
  194.   vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
  195.   vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
  196.   vm:simple-array-double-float-type vm:complex-string-type
  197.   vm:complex-bit-vector-type vm:complex-vector-type)
  198.  
  199. (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
  200.   vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  201.   vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  202.   vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  203.   vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  204.   vm:simple-array-single-float-type vm:simple-array-double-float-type)
  205.  
  206. (def-type-vops arrayp check-array nil object-not-array-error
  207.   vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  208.   vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  209.   vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  210.   vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  211.   vm:simple-array-single-float-type vm:simple-array-double-float-type
  212.   vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
  213.   vm:complex-array-type)
  214.  
  215. (def-type-vops numberp check-number nil object-not-number-error
  216.   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
  217.   vm:single-float-type vm:double-float-type vm:complex-type)
  218.  
  219. (def-type-vops rationalp check-rational nil object-not-rational-error
  220.   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
  221.  
  222. (def-type-vops integerp check-integer nil object-not-integer-error
  223.   vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type)
  224.  
  225. (def-type-vops floatp check-float nil object-not-float-error
  226.   vm:single-float-type vm:double-float-type)
  227.  
  228. (def-type-vops realp check-real nil object-not-real-error
  229.   vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
  230.   vm:single-float-type vm:double-float-type)
  231.  
  232.  
  233. ;;;; Other integer ranges.
  234.  
  235. ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
  236. ;;; exactly one digit.
  237.  
  238. (define-vop (signed-byte-32-p type-predicate)
  239.   (:translate signed-byte-32-p)
  240.   (:generator 45
  241.     (let ((not-target (gen-label)))
  242.       (multiple-value-bind
  243.       (yep nope)
  244.       (if not-p
  245.           (values not-target target)
  246.           (values target not-target))
  247.     (inst andcc zero-tn value #x3)
  248.     (inst b :eq yep)
  249.     (test-type value temp nope t vm:other-pointer-type)
  250.     (loadw temp value 0 vm:other-pointer-type)
  251.     (inst cmp temp (+ (ash 1 vm:type-bits)
  252.               vm:bignum-type))
  253.     (inst b (if not-p :ne :eq) target)
  254.     (inst nop)
  255.     (emit-label not-target)))))
  256.  
  257. (define-vop (check-signed-byte-32 check-type)
  258.   (:generator 45
  259.     (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
  260.       (yep (gen-label)))
  261.       (inst andcc temp value #x3)
  262.       (inst b :eq yep)
  263.       (test-type value temp nope t vm:other-pointer-type)
  264.       (loadw temp value 0 vm:other-pointer-type)
  265.       (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
  266.       (inst b :ne nope)
  267.       (inst nop)
  268.       (emit-label yep)
  269.       (move result value))))
  270.  
  271.  
  272. ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
  273. ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
  274. ;;; and the second digit all zeros.
  275.  
  276. (define-vop (unsigned-byte-32-p type-predicate)
  277.   (:translate unsigned-byte-32-p)
  278.   (:generator 45
  279.     (let ((not-target (gen-label))
  280.       (single-word (gen-label))
  281.       (fixnum (gen-label)))
  282.       (multiple-value-bind
  283.       (yep nope)
  284.       (if not-p
  285.           (values not-target target)
  286.           (values target not-target))
  287.     ;; Is it a fixnum?
  288.     (inst andcc temp value #x3)
  289.     (inst b :eq fixnum)
  290.     (inst cmp value)
  291.  
  292.     ;; If not, is it an other pointer?
  293.     (test-type value temp nope t vm:other-pointer-type)
  294.     ;; Get the header.
  295.     (loadw temp value 0 vm:other-pointer-type)
  296.     ;; Is it one?
  297.     (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
  298.     (inst b :eq single-word)
  299.     ;; If it's other than two, we can't be an (unsigned-byte 32)
  300.     (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
  301.     (inst b :ne nope)
  302.     ;; Get the second digit.
  303.     (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  304.     ;; All zeros, its an (unsigned-byte 32).
  305.     (inst cmp temp)
  306.     (inst b :eq yep)
  307.     (inst nop)
  308.     ;; Otherwise, it isn't.
  309.     (inst b nope)
  310.     (inst nop)
  311.     
  312.     (emit-label single-word)
  313.     ;; Get the single digit.
  314.     (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
  315.     (inst cmp temp)
  316.  
  317.     ;; positive implies (unsigned-byte 32).
  318.     (emit-label fixnum)
  319.     (inst b (if not-p :lt :ge) target)
  320.     (inst nop)
  321.  
  322.     (emit-label not-target)))))      
  323.  
  324. (define-vop (check-unsigned-byte-32 check-type)
  325.   (:generator 45
  326.     (let ((nope
  327.        (generate-error-code vop object-not-unsigned-byte-32-error value))
  328.       (yep (gen-label))
  329.       (fixnum (gen-label))
  330.       (single-word (gen-label)))
  331.       ;; Is it a fixnum?
  332.       (inst andcc temp value #x3)
  333.       (inst b :eq fixnum)
  334.       (inst cmp value)
  335.  
  336.       ;; If not, is it an other pointer?
  337.       (test-type value temp nope t vm:other-pointer-type)
  338.       ;; Get the number of digits.
  339.       (loadw temp value 0 vm:other-pointer-type)
  340.       ;; Is it one?
  341.       (inst cmp temp (+ (ash 1 vm:type-bits) vm:bignum-type))
  342.       (inst b :eq single-word)
  343.       ;; If it's other than two, we can't be an (unsigned-byte 32)
  344.       (inst cmp temp (+ (ash 2 vm:type-bits) vm:bignum-type))
  345.       (inst b :ne nope)
  346.       ;; Get the second digit.
  347.       (loadw temp value (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  348.       ;; All zeros, its an (unsigned-byte 32).
  349.       (inst cmp temp)
  350.       (inst b :eq yep)
  351.       ;; Otherwise, it isn't.
  352.       (inst b :ne nope)
  353.       (inst nop)
  354.       
  355.       (emit-label single-word)
  356.       ;; Get the single digit.
  357.       (loadw temp value vm:bignum-digits-offset vm:other-pointer-type)
  358.       ;; positive implies (unsigned-byte 32).
  359.       (inst cmp temp)
  360.       
  361.       (emit-label fixnum)
  362.       (inst b :lt nope)
  363.       (inst nop)
  364.       
  365.       (emit-label yep)
  366.       (move result value))))
  367.  
  368.  
  369.  
  370.  
  371. ;;;; List/symbol types:
  372. ;;; 
  373. ;;; symbolp (or symbol (eq nil))
  374. ;;; consp (and list (not (eq nil)))
  375.  
  376. (define-vop (symbolp type-predicate)
  377.   (:translate symbolp)
  378.   (:generator 12
  379.     (let* ((drop-thru (gen-label))
  380.        (is-symbol-label (if not-p drop-thru target)))
  381.       (inst cmp value null-tn)
  382.       (inst b :eq is-symbol-label)
  383.       (test-type value temp target not-p vm:symbol-header-type)
  384.       (emit-label drop-thru))))
  385.  
  386. (define-vop (check-symbol check-type)
  387.   (:generator 12
  388.     (let ((drop-thru (gen-label))
  389.       (error (generate-error-code vop object-not-symbol-error value)))
  390.       (inst cmp value null-tn)
  391.       (inst b :eq drop-thru)
  392.       (test-type value temp error t vm:symbol-header-type)
  393.       (emit-label drop-thru)
  394.       (move result value))))
  395.   
  396. (define-vop (consp type-predicate)
  397.   (:translate consp)
  398.   (:generator 8
  399.     (let* ((drop-thru (gen-label))
  400.        (is-not-cons-label (if not-p target drop-thru)))
  401.       (inst cmp value null-tn)
  402.       (inst b :eq is-not-cons-label)
  403.       (test-type value temp target not-p vm:list-pointer-type)
  404.       (emit-label drop-thru))))
  405.  
  406. (define-vop (check-cons check-type)
  407.   (:generator 8
  408.     (let ((error (generate-error-code vop object-not-cons-error value)))
  409.       (inst cmp value null-tn)
  410.       (inst b :eq error)
  411.       (test-type value temp error t vm:list-pointer-type)
  412.       (move result value))))
  413.  
  414.  
  415. ;;;; Function Coercion
  416.  
  417. ;;; If not a function, get the symbol value and test for that being a
  418. ;;; function.  Since we test for a function rather than the unbound
  419. ;;; marker, this works on NIL.
  420. ;;;
  421. (define-vop (coerce-to-function)
  422.   (:args (object :scs (descriptor-reg)
  423.          :target result))
  424.   (:results (result :scs (descriptor-reg)))
  425.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  426.   (:temporary (:scs (descriptor-reg)) saved-object)
  427.   (:vop-var vop)
  428.   (:save-p :compute-only)
  429.   (:generator 0
  430.     (let ((not-function-label (gen-label))
  431.       (not-coercable-label (gen-label))
  432.       (done-label (gen-label)))
  433.       (test-type object nd-temp not-function-label t
  434.          vm:function-pointer-type)
  435.       (move result object)
  436.       (emit-label done-label)
  437.  
  438.       (assemble (*elsewhere*)
  439.     (emit-label not-function-label)
  440.     (test-type object nd-temp not-coercable-label t
  441.            vm:symbol-header-type)
  442.     (move saved-object object)
  443.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  444.     (test-type result nd-temp done-label nil
  445.            vm:function-pointer-type)
  446.     (error-call vop undefined-symbol-error saved-object)
  447.     
  448.     (emit-label not-coercable-label)
  449.     (error-call vop object-not-coercable-to-function-error object)))))
  450.  
  451. (define-vop (fast-safe-coerce-to-function)
  452.   (:args (object :scs (descriptor-reg)
  453.          :target result))
  454.   (:results (result :scs (descriptor-reg)))
  455.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  456.   (:temporary (:scs (descriptor-reg)) saved-object)
  457.   (:vop-var vop)
  458.   (:save-p :compute-only)
  459.   (:generator 10
  460.     (let ((not-function-label (gen-label))
  461.       (done-label (gen-label)))
  462.       (test-type object nd-temp not-function-label t vm:function-pointer-type)
  463.       (move result object)
  464.       (emit-label done-label)
  465.  
  466.       (assemble (*elsewhere*)
  467.     (emit-label not-function-label)
  468.     (move saved-object object)
  469.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  470.     (test-type result nd-temp done-label nil vm:function-pointer-type)
  471.     (error-call vop undefined-symbol-error saved-object)))))
  472.